"Module": "'prevent needless paints\r\nDim resizing%\r\nGlobal nl$\r\n'types\r\nType rect\r\n\tleft As Integer\r\n\ttop As Integer\r\n\tright As Integer\r\n\tbottom As Integer\r\nEnd Type\r\n\r\n'each list needs a caption and bitmap, so declare a simple structure\r\nType ITEMDATA\r\n\ttext As String\r\n\tpic As Integer\r\nEnd Type\r\n\r\n'variable data for each window - each instance of the list is created\r\n'by declaring a listdata structure\r\nType LISTDATA\r\n\tcellwidth As Integer 'w,h of each item\r\n\tcellheight As Integer\r\n\tpicx As Integer 'x,y offset of bmp\r\n\tpicy As Integer\r\n\tpicwidth As Integer\r\n\tpicheight As Integer\r\n\ttextrect As rect 'x,y offset,r,b offset of caption\r\n\tbcolor As Long 'window background color\r\n\tfcolor As Long 'window text\r\n\thilitebcolor As Long '\r\n\thilitefcolor As Long '\r\n\ttoprow As Integer 'client area's top\r\n\titemcount As Integer 'total items\r\n\tactive As Integer 'active item\r\n\tcols As Integer\r\n\trows As Integer\r\n\tvisrows As Integer\r\n\tWidth As Integer\r\n\ttx As Integer\r\n\tty As Integer\r\nEnd Type\r\n\r\n'API constants and types====================\r\nGlobal Const black = &H0\r\nGlobal Const white = &HFFFFFF\r\nGlobal Const lgrey = &HC0C0C0\r\nGlobal Const PATPAINT = &HFB0A09\r\nGlobal Const PATCOPY = &HF00021\r\nGlobal Const SRCCOPY = &HCC0020\r\nGlobal Const GWW_HINSTANCE = (-6)\r\nGlobal Const WM_USER = &H400\r\nGlobal Const GWL_STYLE = (-16)\r\n'draw text\r\nGlobal Const DT_CALCRECT = &H400\r\nGlobal Const DT_CENTER = &H1\r\nGlobal Const DT_NOPREFIX = &H800\r\nGlobal Const DT_VCENTER = &H4\r\nGlobal Const DT_WORDBREAK = &H10\r\nGlobal Const DT_INTERNAL = &H1000\r\nGlobal Const DT_SINGLELINE = &H20\r\nGlobal Const DT_LEFT = &H0\r\nGlobal Const DT_GETRECT = DT_CALCRECT Or DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK\r\nGlobal Const DT_ICONCAP = DT_NOPREFIX Or DT_WORDBREAK Or DT_CENTER\r\nGlobal Const DT_LISTCAP = DT_NOPREFIX Or DT_LEFT ' Or DT_WORDBREAK Or DT_SINGLELINE\r\nGlobal Const DT_ICONTITLE = DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK 'Or DT_VCENTER\r\nDeclare Function bitblt% Lib \"GDI\" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&)\r\nDeclare Function CreateDC Lib \"GDI\" (ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput As Any, ByVal lpInitData As Any) As Integer\r\nDeclare Function CreateSolidBrush% Lib \"GDI\" (ByVal crColor&)\r\nDeclare Function DeleteDC Lib \"GDI\" (ByVal hDC As Integer) As Integer\r\nDeclare Function DeleteObject% Lib \"GDI\" (ByVal hObject%)\r\nDeclare Function DrawText% Lib \"User\" (ByVal hDC%, ByVal lpStr$, ByVal nCount%, lpRect As rect, ByVal wFormat%)\r\nDeclare Function DrawIcon Lib \"USER\" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal hicon As Integer) As Integer\r\nDeclare Function ExtractIcon Lib \"shell\" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer\r\nDeclare Function GetSysColor& Lib \"User\" (ByVal nIndex%)\r\nDeclare Function GetWindowWord Lib \"User\" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer\r\nDeclare Function SetTextColor& Lib \"GDI\" (ByVal hDC%, ByVal crColor&)\r\nDeclare Function PatBlt% Lib \"GDI\" (ByVal hDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal dwRop&)\r\nDeclare Function SelectObject% Lib \"GDI\" (ByVal hDC%, ByVal hObject%)\r\n\r\nSub InitializeList (ld As LISTDATA, L As PictureBox)\r\nDim i%, s$\r\nld.bcolor = GetSysColor(5)\r\nld.fcolor = GetSysColor(8)\r\nld.hilitebcolor = GetSysColor(13)\r\nld.hilitefcolor = GetSysColor(14)\r\nld.tx = screen.TwipsPerPixelX\r\nld.ty = screen.TwipsPerPixelY\r\n\r\nld.toprow = 0\r\nld.active = 1\r\nld.textrect.right = ld.cellwidth - 2 * ld.textrect.left\r\nld.textrect.bottom = ld.cellheight - ld.textrect.top\r\nEnd Sub\r\n\r\nSub ItemClick (F As Form, ld As LISTDATA, txt() As ITEMDATA, x!, y!, L As PictureBox)\r\nDim n%, old%\r\nDim tr As rect, hr As rect\r\n\r\n'===set focus to clicked item=====================\r\ny = y \\ ld.cellheight: 'Debug.Print x, y\r\n'determine relative item #\r\nn = y + 1'Debug.Print n\r\n'determine absolute item #\r\nn = n + ld.toprow'Debug.Print n\r\n'set active item\r\nIf n <= ld.itemcount Then\r\n 'old is a 1-based index; the draw routine uses a 0-base\r\n old% = ld.active - 1\r\n ld.active = n\r\nEnd If\r\n\r\n'erase old hilite\r\nhr.left = ld.picx + ld.picwidth\r\nhr.right = ld.Width\r\ntr.left = ld.picx + ld.picwidth + ld.textrect.left\r\ntr.right = ld.Width - ld.textrect.left\r\n'valid index?\r\nIf old >= 0 And old < ld.itemcount Then\r\n 'is it still visible?\r\n n = old - ld.toprow\r\n If n >= 0 And n < ld.visrows Then\r\n\t\r\n\t'size of text rect:\r\n\ttr.top = n * ld.cellheight + ld.textrect.top\r\n\ttr.bottom = (n + 1) * ld.cellheight\r\n\t'\r\n\t'size of hilite rect\r\n\thr.top = n * ld.cellheight\r\n\thr.bottom = tr.bottom + 2\r\n\tPaintHilite 0, txt(old + 1).text, tr, hr, ld, L\r\n End If\r\nEnd If\r\n\r\n'draw new hilite\r\nn = ld.active - 1 - ld.toprow: 'Debug.Print \"rel\" & n\r\n 'check if its visible:'Debug.Print \"total\" & ld.visrows * ld.cols\r\n If n < 0 Or n > ld.visrows - 1 Then Exit Sub\r\n \r\n 'size of text rect:\r\n tr.top = n * ld.cellheight + 8\r\n tr.bottom = (n + 1) * ld.cellheight 'Debug.Print hr.left, hr.top, hr.right, hr.bottom\r\n 'size of hilite rect\r\n hr.top = tr.top - 8\r\n hr.bottom = tr.bottom + 2\r\n PaintHilite -1, txt(ld.active).text, tr, hr, ld, L\r\n\r\nEnd Sub\r\n\r\nSub PaintHilite (op%, s$, tr As rect, hr As rect, ld As LISTDATA, L As PictureBox)\r\nDim bkgcolor&, txtcolor&, r%\r\nDim offset%'offset of icon caption\r\nDim hbrOld%, hbr%, cOld& 'api stuff\r\n'\r\n'n = 0 erase hilite; n = -1 paint hilite\r\nIf op Then\r\n bkgcolor& = ld.hilitebcolor\r\n txtcolor& = ld.hilitefcolor\r\nElse\r\n bkgcolor& = ld.bcolor\r\n txtcolor = ld.fcolor\r\nEnd If\r\n\r\n'paint a hilite rectangle:\r\nhbr = CreateSolidBrush(bkgcolor&)\r\nhbrOld = SelectObject(L.hDC, hbr)\r\nr = PatBlt(L.hDC, hr.left, hr.top, hr.right - hr.left, hr.bottom - hr.top, PATCOPY)\r\nL.Line (0, hr.top)-(ld.picwidth + 1, hr.top + ld.cellheight), bkgcolor&, B\r\n\r\n'paint hilite text:\r\ncOld = SetTextColor(L.hDC, txtcolor&)\r\nr = DrawText(L.hDC, s, Len(s), tr, DT_LISTCAP)\r\n\r\n'cleanup\r\ncOld = SetTextColor(L.hDC, cOld)\r\nhbr = SelectObject(L.hDC, hbrOld)\r\nr = DeleteObject(hbr)\r\nEnd Sub\r\n\r\nSub PaintList (ld As LISTDATA, txt() As ITEMDATA, p As PictureBox, L As PictureBox)\r\nDim i%, r%\r\nDim y% 'y pos to draw icon\r\nDim ypos% 'y pos of item\r\nDim pstart%, pend% 'indexes of first and last visible icons\r\nDim hr As rect, tr As rect 'for drawing text\r\n\r\n'calculate which icons to show:\r\npstart% = ld.toprow + 1': Debug.Print pstart\r\npend% = pstart% + ld.visrows - 1\r\nIf pend% > ld.itemcount Then pend% = ld.itemcount: Debug.Print pend\r\n'\r\nL.Cls\r\n'draw the icons:\r\ny = -ld.cellheight + 2\r\nFor i = pstart% To pend%\r\n y = y + ld.cellheight'(new row)\r\n r = bitblt(L.hDC, ld.picx, y + ld.picy, ld.picwidth, ld.picheight, p.hDC, txt(i).pic * ld.picwidth, 0, SRCCOPY)\r\nNext\r\n\r\ny = -ld.cellheight\r\ntr.left = ld.picx + ld.picwidth + ld.textrect.left\r\ntr.right = ld.Width' - tr.left\r\nFor i = pstart% To pend%\r\n y = y + ld.cellheight'(new row)\r\n 'define the rect to draw text in:\r\n tr.top = y + ld.textrect.top\r\n tr.bottom = y + ld.cellheight\r\n '\r\n If i = ld.active Then\r\n\thr.left = ld.picx + ld.picwidth\r\n\thr.top = y\r\n\thr.bottom = y + ld.cellheight\r\n\thr.right = L.ScaleWidth\r\n\tDebug.Print txt(i).text\r\n\tPaintHilite -1, txt(i).text, tr, hr, ld, L\r\n Else\r\n\tDebug.Print txt(i).text\r\n\tr = DrawText(L.hDC, txt(i).text, Len(txt(i).text), tr, DT_LISTCAP)\r\n End If\r\nNext\r\nExit Sub\r\n'\r\npaintlisterr:\r\nMsgBox \"Err: \" & Err & nl & Error(Err), , \"UNABLE TO PAINT WINDOW\"\r\nExit Sub\r\n\r\nEnd Sub\r\n\r\nSub ResizeList (F As Form, ld As LISTDATA, L As PictureBox)\r\n'Dim x%, y%\r\n'Dim r As rect\r\nDebug.Print \"Resizing\"\r\nresizing = -1\r\n'\r\nld.rows = ld.itemcount\r\nIf ld.rows < 1 Then ld.rows = 1\r\nld.cols = 1\r\nld.visrows = L.ScaleHeight \\ ld.cellheight + 1\r\nDebug.Print ld.rows, ld.visrows\r\n\r\n'F.vs.Enabled = 0\r\n'\r\nIf ld.rows > ld.visrows Then\r\n 'F.vs.Move L.ScaleWidth - F.vs.Width, 0, F.vs.Width, F.ScaleHeight\r\n F.vs.Enabled = -1\r\n F.vs.Max = ld.rows - ld.visrows\r\nElse\r\n ld.toprow = 0\r\n F.vs.Enabled = 0\r\nEnd If\r\nld.Width = L.ScaleWidth\r\n'\r\nresizing = 0\r\nld.textrect.right = L.Width - (ld.picx + ld.picwidth + ld.textrect.left)\r\n\r\nEnd Sub\r\n\r\n",
"Form": "BINARY_FILE:Listboxes/0_Form",
"FormCode": "Option Explicit\r\nDim loading%\r\n'structure holding the data for\r\n'for this window's listbox\r\nDim ld As LISTDATA\r\n'this array holds the items in the list\r\nDim items() As ITEMDATA\r\n\r\nSub Form_Load ()\r\nDim i%, x%\r\nReDim items(0 To 40)\r\nFor i = 0 To 40\r\n items(i).text = \"Item \" & Format$(i)\r\n x = i Mod 5\r\n items(i).pic = x\r\n 'Debug.Print x\r\n 'Debug.Print items(i).text\r\nNext\r\nInit\r\nEnd Sub\r\n\r\nSub Form_Resize ()\r\n'do whatever this instance requires\r\nList.Move 120, 120, scalewidth - vs.Width - 240, scaleheight - 240\r\nvs.Move List.Width + 120 - screen.TwipsPerPixelX, 120, vs.Width, List.Height\r\n'call the module\r\nResizeList Me, ld, List\r\nEnd Sub\r\n\r\nSub Init ()\r\nnl$ = Chr$(13) + Chr$(10)\r\n'fill in the structure for this instance\r\n\r\n'size of an item\r\nld.cellheight = 32\r\nld.cellwidth = List.Width\r\n\r\n'size of the bitmap\r\nld.picx = 0: ld.picy = 0\r\nld.picwidth = 32\r\nld.picheight = 32\r\n\r\n'location of text with the cell\r\nld.textrect.left = 40\r\nld.textrect.top = 8\r\n\r\n'number of items\r\nld.itemcount = 40\r\nInitializeList ld, List\r\n\r\nEnd Sub\r\n\r\nSub List_MouseDown (Button As Integer, Shift As Integer, x As Single, Y As Single)\r\nItemClick Me, ld, items(), x, Y, List\r\nEnd Sub\r\n\r\nSub List_Paint ()\r\nIf Not loading% Then PaintList ld, items(), pics, List\r\nEnd Sub\r\n\r\nSub vs_Change ()\r\nDim n%\r\nn = (vs.Value)\r\n'Debug.Print \"toprow=\" & n\r\n'toprow range: 0=1st row,1=2nd, etc\r\nld.toprow = n\r\nList_Paint\r\n\r\nEnd Sub\r\n\r\n"
